;; Copyright 2010 Peter Goncharov

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or	
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(in-package :cl-money-type)

(defstruct (money (:print-function print-money)) (amount 0) (prec 2))

(defun print-money (money str depth)
 (declare (ignore depth))
 (let ((p (money-prec money)))
   (if (< 0 p)
       (format str "~v,1,,'0$" p (money-amount money))
       (format str "~d" (round (money-amount money))))))

(defmethod change-precision ((money money) (precision integer))
  (make-money :amount (money-amount money) :prec precision))

(defmethod change-precision* ((money money) (precision integer))
  (setf (money-prec money) precision))

(defun round-to-prec (money &optional prec)
  (etypecase money
    (money (let ((divisor (if prec (/ 1 (expt 10 prec))
			  (/ 1 (expt 10 (money-prec money))))))
	 (* (round (money-amount money) divisor)
	    divisor)))
    (rational (let ((divisor (/ 1 (expt 10 prec))))
		(* (round money divisor) divisor)))))

;;; Exact equal
(defgeneric money-equal (val-a val-b))

(defmethod money-equal ((val-a money) (val-b money))
  (= (money-amount val-a) (money-amount val-b)))

(defmethod money-equal ((val-a rational) (val-b rational))
  (= val-a val-b))

(defmethod money-equal ((val-a money) (val-b rational))
  (= (money-amount val-a) val-b))

(defmethod money-equal ((val-a rational) (val-b money))
  (money-equal val-b val-a))

(defgeneric money-not-equal (val-a val-b)
  (:method (val-a val-b)
    (not (money-equal val-a val-b))))

;;; Equal rounded to precision

(defgeneric money-equalp (val-a val-b))

(def-op-r-r money-equalp =)

(def-op-m-m money-equalp money-equal)

(def-op-m-r money-equalp money-equal)

(defgeneric money-not-equalp (val-a val-b)
  (:method (val-a val-b)
    (not (money-equalp val-a val-b))))

(defgeneric money= (val-a val-b)
  (:method (val-a val-b)
      (money-equalp val-a val-b)))

(defgeneric money/= (val-a val-b)
  (:method (val-a val-b)
    (not (money-equalp val-a val-b))))

;;; Money comparison

(defgeneric money< (val-a val-b))
(def-operations money< <)

(defgeneric money<= (val-a val-b))
(def-operations money<= <=)

(defgeneric money> (val-a val-b))
(def-operations money> >)

(defgeneric money>= (val-a val-b))
(def-operations money>= >=)

;;; Money add
(defgeneric add (val-a val-b))
(def-ar-operations add +)

;;; Money subtract

(defgeneric subtract (val-a val-b))
(def-ar-operations subtract -)

;;; Money mult

(defgeneric multiply (val-a val-b))
(def-ar-operations multiply *)

;;; Money divide

(defgeneric divide (val-a val-b))
(def-ar-operations divide /)

;;; Misc

(defun format-money (money)
  (print-money money nil nil))

(defun float-to-money (amount prec)
  (make-money :amount (round-to-ratio amount prec) :prec prec))

;;; Functions for arithmetic operations on multiple values

(defun Sum (&rest args)
  (reduce #'add args))

(defun Sub (&rest args)
  (reduce #'subtract args))

(defun Mult (&rest args)
  (reduce #'multiply args))

(defun Div (&rest args)
  (reduce #'divide args))

;;; Maximize/minimize

(defun money-max (m1 m2)
  (if (money< m1 m2) m2 m1))

(defun money-min (m1 m2)
  (if (money< m1 m2) m1 m2))

(defun m-maximum (&rest moneys)
  (reduce #'money-max moneys))

(defun m-minimum (&rest moneys)
  (reduce #'money-min moneys))

;;; Round
(defun round-to-ratio (number precision &optional (round-function #'round))
  "Reduces the NUMBER up to a PRECISION number of decimal places, return a ration.
Round-function is one of
  #'floor
  #'ceil
  #'truncate
  #'round (is default)."
  (let ((div (expt 10 precision)))
    (/ (funcall round-function (* number div)) div)))

(defmethod round-money-to ((m money) prec &optional (round-fn #'ceiling))
  (make-money :amount (round-to-ratio (money-amount m) prec round-fn)
	      :prec prec))